home *** CD-ROM | disk | FTP | other *** search
/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / info-service / gopher / VieGOPHER / rose.exec < prev    next >
Encoding:
Text File  |  1993-06-16  |  14.4 KB  |  482 lines
  1. /* ------------------------------------------------------------------- */
  2. /* File ROSE.EXEC                       1993-05-26/18:10  Ver  1.00.34 */
  3. /*                                                                     */
  4. /* Generate and configure REXX and XEDIT scripts from a PRODUCT file.  */
  5. /* Generating ASSEMBLE files in fixed format is supported.             */
  6. /*                                                                     */
  7. /* Usage: ROSE product fix (options                                    */
  8. /* Options:                                                            */
  9. /*   level=<n>   ... prompt level                                      */
  10. /*                   1 .. everything                                   */
  11. /*                   2 .. only unfixed items                           */
  12. /*                   3 .. dont dare to ask                             */
  13. /*                                                                     */
  14. /* written:       1992-08-17 <Gerhard.Gonter@wu-wien.ac.at>            */
  15. /* latest update: 1993-05-26                                           */
  16. /* ------------------------------------------------------------------- */
  17.  
  18. parse arg product fix '('opts
  19.  
  20. DL=0;                   /* debugging level                 */
  21. program='ROSE'
  22. RWdisk='A';
  23. prompt_level=2;         /* 1 .. ask for everything         */
  24.                         /* 2 .. ask for unfixed items only */
  25.                         /* 3 .. dont dare to ask at all    */
  26.  
  27. if product='' then do;
  28.   do zeile = 1
  29.     if substr(sourceline(zeile),1,2) /= "/*" then exit(0);
  30.     say sourceline(zeile);
  31.   end;
  32. end;
  33.  
  34. upper product fix;
  35. if fix='' then fix=product
  36.  
  37. do while opts/='';
  38.   parse var opts opt opts
  39.   if left(opt,6)='level=' then prompt_level=substr(opt,7);
  40. end;
  41.  
  42. x=get_fileinfo();
  43. x=init_vars();
  44. if fix_size>0 then x=proc_fix_file();
  45. x=proc_product_file();
  46. x=write_fix(fix_file);
  47.  
  48. exit(0);
  49.  
  50. /* ------------------------------------------------------------------- */
  51. get_fileinfo:
  52.  
  53. /* find out about the PRODUCT file */
  54. q=queued();
  55. 'LISTFILE' product 'PRODUCT * (LIFO ALLOC NOHEAD'
  56. if rc/=0 then do;
  57.   say 'Error: didn''t find product' product
  58.   exit(1);
  59. end;
  60. q=queued()-q;
  61. do q;
  62.   pull fn ft fm . . siz .
  63.   product_file=fn ft fm;
  64.   product_size=siz;
  65. end;
  66. say 'product file:' product_file';' product_size 'lines.'
  67.  
  68. /* find out about the FIX file */
  69. fix_file=fix 'FIX A'
  70. fix_size=0;
  71. q=queued();
  72. 'LISTFILE' fix 'FIX * (LIFO ALLOC NOHEAD'
  73. if rc/=0 then do;
  74.   say 'Note: didn''t find fix' fix 'for product' product
  75. end; else do;
  76.   q=queued()-q;
  77.   do q;
  78.     pull fn ft fm . . siz .
  79.     if substr(fm,1,1)/='A' then do;
  80.       say 'Warning: there is a fix file on 'fm'; I''m not using it...'
  81.     end; else do;
  82.       fix_file=fn ft fm;
  83.       fix_size=siz;
  84.     end;
  85.   end;
  86.   say 'fix     file:' fix_file';' fix_size 'records.'
  87. end;
  88. return 0;
  89.  
  90. /* ------------------------------------------------------------------- */
  91. init_vars:
  92. out_module='';          /* name of file that is currently generated    */
  93. out_recs= 0;            /* number of lines sofar in generated file     */
  94. mod_fixed= 0;           /* 1 .. file is to be written in fixed format  */
  95.  
  96. help_count=0;           /* number of help texts found                  */
  97. help_name.='';          /* name of help items                          */
  98. help_start.='';         /* start of help text for a given item         */
  99. help_size.='';          /* number of help lines for a given item       */
  100. help_point=0;           /* total number of lines for help messages     */
  101. help_text.='';          /* text lines for help messages                */
  102.  
  103. xvar_count=0;           /* number of variables encountered             */
  104. xvar_name.='';          /* name of variables                           */
  105. xvar_value.='';         /* predefined values for the variables         */
  106. xvar_fixed.='';         /* values for variables found in a fix file    */
  107.  
  108. switch_level=0;         /* switch-stack pointer                        */
  109. switch_name.='';        /* name of the control variable                */
  110. switch_type.='';        /* type of the switch statement: SWITCH        */
  111. switch_mode.='';        /* last text_mode for writing                  */
  112. switch_default.='';     /* 1 .. default has to be processed            */
  113. switch_cflg.='';        /* stack for case_flg                          */
  114.  
  115.  
  116. text_mode=0;            /* 0 .. dont generate output but analyze       */
  117.                         /*      ROSE commands                          */
  118.                         /* 1 .. write to text file                     */
  119.                         /* 2 .. store help text                        */
  120. lin.0=0
  121. return 0;
  122.  
  123. /* ------------------------------------------------------------------- */
  124. proc_fix_file:
  125. say 'Note: processing fix file'
  126. do fi=1 to fix_size;
  127.   'EXECIO * DISKR' fix_file '(STEM LIN.'
  128.   if lin.0=0 then leave;
  129.   do i=1 to lin.0;
  130.     x=var_set(lin.i);
  131.   end;
  132. end;
  133. 'FINIS' fix_file
  134. return 0;
  135.  
  136. /* ------------------------------------------------------------------- */
  137. proc_product_file:
  138. say 'Note: processing product file'
  139. case_flg=1;     /* case flag: 1 .. positive case */
  140. do pi=1 to product_size;
  141.   'EXECIO 1 DISKR' product_file '(STEM LIN.'
  142.   if lin.0=0 then do;
  143.     say 'EOF: stop processing of' product_file 'at line' pi
  144.     leave;
  145.   end;
  146.   li=lin.1;
  147.   if substr(li,1,1)='#' & substr(li,1,2)/='##' then do;
  148.     if DL>0 then do;
  149.       say 'textmode='textmode 'product_size='product_size 'pi='pi
  150.       say 'line['pi']='li;
  151.     end;
  152.     if out_module/='' & out_recs/=0 then 'FINIS' out_module;
  153.     parse var li cmd par
  154.     select;
  155.       when cmd='#help' & case_flg=1 then do;
  156.         hc= help_count;
  157.         help_count= help_count+1;
  158.         help_name.hc= par;
  159.         help_start.hc= help_point;
  160.         text_mode= 2;
  161.       end;
  162.       when cmd='#endhelp' then do;
  163.         text_mode= 0;
  164.       end;
  165.       when cmd='#set' & case_flg=1 then do;
  166.         x= var_set('VALUE' par);
  167.       end;
  168.       when cmd='#prompt' & case_flg=1 then do;
  169.         x= prompt(par);
  170.         if x=-1 then signal STOP;
  171.       end;
  172.       when cmd='#fix' then do;
  173.         vii=var_find(par);
  174.         if vii/=-1 then do;
  175.           if text_mode=1 then do;
  176.             lin.0=1;
  177.             lin.1=xvar_value.vii;
  178.             out_recs= out_recs+1;
  179.             if mod_fixed=1 then do;
  180.               LIN.1= fixed_line(LIN.1, out_recs);
  181.               'EXECIO 1 DISKW' out_module out_recs 'F (STEM LIN.'
  182.             end; else do;
  183.              'EXECIO 1 DISKW' out_module '(STEM LIN.'
  184.             end;
  185.           end; else do;
  186.             say 'fix value for' par 'is:' xvar_value.vii;
  187.           end;
  188.         end;
  189.       end;
  190.       when cmd='#erase' & case_flg=1 then do;
  191.         out_module=par RWdisk;
  192.         upper out_module;
  193.         address command 'STATEW' out_module;
  194.         if rc=0 then do;
  195.           say 'erasing module' out_module;
  196.           'ERASE' out_module;
  197.         end; else do;
  198.           address command 'STATE' out_module;
  199.           if rc=0 then say '******* FILE' out_module 'exists on R/O disk'
  200.         end;
  201.       end;
  202.       when cmd='#module' then do;
  203.         parse var par out_module '('mod_opts
  204.         upper mod_opts;
  205.         mod_fixed= 0;
  206.         if index(mod_opts,'FIX')>0 then mod_fixed=1;
  207.         out_recs= 0;
  208.         if words(out_module)/=2 then do;
  209.           say product_file'('pi') invalid module name:' module
  210.           exit(1);
  211.         end;
  212.         out_module=out_module RWdisk;
  213.         upper out_module;
  214.         say 'writing module' out_module;
  215.         text_mode=1;
  216.       end;
  217.       when cmd='#switch' then do;
  218.         switch_name.switch_level=par;
  219.         switch_type.switch_level='SWITCH';
  220.         switch_mode.switch_level=text_mode;
  221.         switch_default.switch_level=1;
  222.         switch_cflg.switch_level=1;
  223.         switch_level=switch_level+1;
  224.         text_mode=0;
  225.       end;
  226.       when cmd='#case' | cmd='#default' then do;
  227.         text_mode=0;
  228.         if switch_level<1 then do;
  229.           say product_file'('pi') error: invalid' li
  230.           exit(1);
  231.         end;
  232.         swlev=switch_level-1;
  233.         if switch_mode.swlev/=0 then do;
  234.           /* more text will be processed only when output was   */
  235.           /* generated before, otherwise ignore any text.       */
  236.           dp=0; /* do processing of block; otherwise skip block */
  237.           case_flg=0; /* *************** ATTENTION ************ */
  238.           if cmd='#case' then do;
  239.             vii=var_find(switch_name.swlev);
  240.             if vii/= -1 then do;
  241.               if xvar_value.vii=par then do;
  242.                 dp=1;
  243.                 switch_default.swlev=0;
  244.               end;
  245.             end;
  246.           end;
  247.           if cmd='#default' & switch_default.swlev=1 then dp=1;
  248.           if dp=1 then do;
  249.             text_mode=switch_mode.swlev;
  250.             case_flg=1;
  251.           end;
  252.         end;
  253.       end;
  254.       when cmd='#endswitch' then do;
  255.         if switch_level<1 then do;
  256.           say product_file'('pi') error: invalid' li
  257.           exit(1);
  258.         end;
  259.         switch_level=switch_level-1;
  260.         text_mode=switch_mode.switch_level;
  261.         case_flg=switch_cflg.switch_level;
  262.       end;
  263.       when cmd='#call' then do;
  264.         parse var par pgm par
  265.         pgm_line= pgm;
  266.         do while par/='';
  267.           parse var par xpar par;
  268.           vii= var_find(xpar);
  269.           if vii/= -1 then xpar= xvar_value.vii;
  270.           pgm_line= pgm_line xpar;
  271.         end;
  272.         say 'executing:' pgm_line
  273.         interpret pgm_line
  274.       end;
  275.       when cmd='#end' then signal STOP;
  276.       when cmd='#' then do;
  277.         /* nothing, just comment */
  278.       end;
  279.       when cmd='#section'       | cmd='#subsection'  |,
  280.            cmd='#subsubsection' | cmd='#paragraph'   |,
  281.            cmd='#verbatim'      | cmd='#endverbatim' | cmd='#v' then do;
  282.         /* nothing; these commands are for typesetting */
  283.       end;
  284.       otherwise do;
  285.           say product_file'('pi') warning: unknown command' li
  286.       end;
  287.     end/*select*/;
  288.   end; else do; /* normal text */
  289.     if substr(li,1,2)='##' then li=substr(li,2); /* chop off first # */
  290.     do forever;
  291.       mii=index(li,'#<');
  292.       if mii=0 then leave;
  293.       mij=index(li,'>#');
  294.       if mij=0 | mij < mii then do;
  295.         say product_file'('pi') error: macro syntax:' li
  296.         exit(1);
  297.       end;
  298.       mnam=substr(li,mii+2,mij-mii-2);
  299.       vii=var_find(mnam);
  300.       if vii=-1 then do;
  301.         say product_file'('pi') error: macro name:' li
  302.         exit(1);
  303.       end;
  304.       li=substr(li,1,mii-1)||xvar_value.vii||substr(li,mij+2);
  305.     end;
  306.     lin.1=li;
  307.     select;
  308.       when text_mode=1 then do; /* text to file */
  309.         lin.0=1;
  310.         out_recs= out_recs+1;
  311.         if mod_fixed=1 then do;
  312.           LIN.1= fixed_line(LIN.1, out_recs);
  313.           'EXECIO 1 DISKW' out_module out_recs 'F (STEM LIN.'
  314.         end; else do;
  315.           'EXECIO 1 DISKW' out_module '(STEM LIN.'
  316.         end;
  317.       end;
  318.       when text_mode=2 then do; /* text to help buffer */
  319.         help_text.help_point=li;
  320.         help_point=help_point+1;
  321.       end;
  322.       otherwise do; /* nothing .. */ end;
  323.     end/*select*/
  324.   end;
  325. end;
  326. say 'pi='pi
  327.  
  328. STOP:
  329. 'FINIS' product_file
  330. return 0;
  331.  
  332. /* ------------------------------------------------------------------- */
  333. var_set: parse arg what nam val
  334. vii=var_find(nam);
  335. if vii= -1 then do;
  336.   vii=xvar_count;
  337.   xvar_count=xvar_count+1;
  338.   xvar_name.vii=nam;
  339.   if what='VALUE' then do;
  340.     xvar_fixed.vii='';
  341.   end;
  342.   if what='FIX' then do;
  343.     xvar_value.vii=nam;
  344.   end;
  345. end;
  346. if what='VALUE' then do;
  347.   xvar_value.vii=val;
  348. end;
  349. if what='FIX' then do;
  350.   xvar_fixed.vii=val;
  351. end;
  352. return 0;
  353.  
  354. /* ------------------------------------------------------------------- */
  355. var_find: parse arg nam .
  356. vii=-1;
  357. do vi=0 to xvar_count-1;
  358.   if xvar_name.vi=nam then vii=vi;
  359. end;
  360. return vii;
  361.  
  362. /* ------------------------------------------------------------------- */
  363. help_find: parse arg nam .
  364. hii=-1;
  365. /* say 'help_count='help_count  'nam='nam */
  366. do hi=0 to help_count-1;
  367.   /* say 'help_name.'hi'='help_name.hi */
  368.   if help_name.hi=nam then hii=hi;
  369. end;
  370. return hii;
  371.  
  372. /* ------------------------------------------------------------------- */
  373. display_help: parse var hii .
  374. if hii=-1 then return -1;
  375. if hii+1 < help_count then hij=help_start.(hii+1); else hij=help_point;
  376. do i=help_start.hii to hij-1;
  377.   say help_text.i;
  378. end;
  379. return 0;
  380.  
  381. /* ------------------------------------------------------------------- */
  382. write_fix: parse arg fnm_fix
  383. 'STATE' fnm_fix
  384. if rc=0 then 'ERASE' fnm_fix;
  385. do i=0 to xvar_count-1;
  386.   lin.0=1;
  387.   lin.1='FIX' xvar_name.i xvar_value.i
  388.   'EXECIO 1 DISKW' fnm_fix '(STEM LIN.'
  389. end;
  390. 'FINIS' fnm_fix;
  391. return 0;
  392.  
  393. /* ------------------------------------------------------------------- */
  394. fixed_line: parse arg str, num
  395. if mod_fixed=0 then return str;
  396. str= substr(str,1,72)||translate(format(num,7),'0',' ')||'0';
  397. return str;
  398.  
  399. /* ------------------------------------------------------------------- */
  400. /* prompt a value for the variable named nam and check it against      */
  401. /* values, if this is specified                                        */
  402. prompt: parse arg nam values
  403.  
  404. vii=var_find(nam);
  405. if (vii=-1) then do;
  406.   say '** WARNING **  Didn''t find a help text for' nam '('arg')'
  407.   return 0;
  408. end;
  409. hii=help_find(nam);
  410. /* say 'help_find('nam') -> 'hii */
  411.  
  412. select;
  413.   when prompt_level=1 then do;
  414.     /* nothing, it's ok to ask */
  415.   end;
  416.   when prompt_level=2 then do;
  417.     if xvar_fixed.vii/='' then do;
  418.       xvar_value.vii=xvar_fixed.vii;
  419.       return 0;
  420.     end;
  421.   end;
  422.   when prompt_level=3 then do;
  423.     if xvar_fixed.vii='' then return -1;
  424.     xvar_value.vii=xvar_vii.fixed;
  425.     return 0;
  426.   end;
  427.   otherwise do;
  428.     say 'illegal prompt level' prompt_level;
  429.     return -1;
  430.   end;
  431. end;
  432.  
  433. c2= 3;
  434. do forever;
  435.   'VMFCLEAR'
  436.   say copies('*',72);
  437.   if hii/=-1 then do;
  438.     x= display_help(hii);
  439.     say '-------';
  440.   end; else say 'fix value for' nam
  441.   say '1. use predefined value:' xvar_value.vii;
  442.   say '2. use fixed value:' xvar_fixed.vii
  443.   say '3. enter new value';
  444.   say 'X. stop';
  445.   pull x1
  446.   if x1='X'|x1='Q' then return -1;
  447.   if x1='1'|x1='' then return 0;
  448.   if x1='2' then do;
  449.     xvar_value.vii= xvar_vii.fixed;
  450.     return 0;
  451.   end;
  452.   if x1='3' then do;
  453.     say 'enter new value for' nam
  454.     parse pull nv;
  455.     ok= 1;
  456.     if values/='' then do;
  457.       ok= 0;
  458.       do c1=1 to words(values);
  459.         if word(values,c1)=nv then ok= 1;
  460.       end;
  461.     end;
  462.     c2= c2-1;
  463.     if ok=0 & c2>0 then iterate;
  464.     xvar_value.vii= nv;
  465.     return 0;
  466.   end;
  467.  
  468.   /* any other value is interpreted as fix value */
  469.   ok= 1;
  470.   if values/='' then do;
  471.     ok= 0;
  472.     do c1=1 to words(values);
  473.       if word(values,c1)=x1 then ok= 1;
  474.     end;
  475.   end;
  476.   c2= c2-1;
  477.   if ok=0 & c2>0 then iterate;
  478.   xvar_value.vii= x1;
  479.   return 0;
  480. end;
  481. return -1;
  482.